home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / COMMUNIC / 0202.ZIP / MODEM7.PAS < prev    next >
Pascal/Delphi Source File  |  1986-05-13  |  18KB  |  570 lines
  1. {$C-} {no user interrupts}
  2. {$U-}
  3. {$K-} {no stack checking - program works}
  4. program Modem;
  5.  
  6. { Written by Jack M. Wierda  Chicago Illinois
  7.   Modified by Steve Freeman
  8.  
  9.       LANGUAGE: TURBO Pascal
  10.       This program is in the public domain.
  11.  
  12.       This program is basically a re-write in PASCAL of Ward Christensen's
  13. Modem Program which was distributed in CP/M User's Group Volume 25. Identical
  14. and compatible options are provided to allow this program to work directly
  15. with XMODEM running under CP/M. }
  16.  
  17. CONST
  18.       Version = '12-Nov-84';
  19.       FredsPhone = '7-5038';
  20.       SignOnLine = 'ACGM10,RLIP,PSSWD';
  21.       MaxPhoneNums = 26;
  22.       COMport = 1;
  23.  
  24.       NUL   =   00;   SOH   = #$01;   EOT   = #$04;   ACK   = #$06;
  25.       TAB   =   09;   LF    = #$0A;   CR    = #$0D;   NAK   = #$15;
  26.       Space = ' ';    DELete = $7F;
  27.  
  28.       lastbyte = 127;
  29.       timeout  = 256;
  30.       errormax = 5;
  31.       retrymax = 5;
  32.       loopspersec = 6500;
  33.       Intseg: integer = 0; {filled with interrupt segment address}
  34.  
  35. TYPE maxstr = string[255];
  36.      PhoneEntry = string[32];
  37.      PhoneStr = string[20];
  38.      BytePointer = ^byte;
  39.  
  40. VAR  COMbase: integer; {this will point to the Communications base}
  41.      WorkFile: file;
  42.      PhoneFile: text;
  43.      PhoneList: array[1..MaxPhoneNums] of PhoneEntry;
  44.      option, hangup, return, mode, baudrate : char;
  45.      sector : array[0..lastbyte] of byte;
  46.      base, N_Phones: integer;
  47.  
  48.      { interrupt vectors and pointers to them }
  49.      newvec, oldvec: BytePointer;
  50.      INT3: BytePointer absolute $0000:$002C; {for COM2:}
  51.      INT4: BytePointer absolute $0000:$0030; {for COM1:}
  52.      rcvbuf: array[0..127] of byte;
  53.      inptr, outptr: integer;
  54.      datardy: boolean;
  55. {.pa}
  56.   TYPE hexstr = string[4];
  57.  
  58.  
  59.   FUNCTION hex(num: integer): hexstr;
  60.     VAR i, j: integer;
  61.         h: string[16];
  62.         str: hexstr;
  63.     BEGIN
  64.       str := '0000';   h := '0123456789ABCDEF';   j := num;
  65.       for i:=4 downto 1
  66.         do BEGIN
  67.              str[i] := h[(j and 15)+1];
  68.              j := j shr 4;
  69.            END;
  70.       hex := str;
  71.     END;
  72.  
  73.  
  74. {.cp10}
  75.   FUNCTION GetYN: char;
  76.     VAR c: char;
  77.     BEGIN
  78.       repeat
  79.           read(kbd,c);
  80.           c := upcase(c);
  81.         until c in ['Y','N'];
  82.       writeln(c);
  83.       GetYN := c
  84.     END;
  85.  
  86.  
  87. {.cp4}
  88.   PROCEDURE SetDTR;
  89.     BEGIN
  90.       port[base+4] := $09; {DTR on and INT enabled}
  91.     END;
  92.  
  93.  
  94. {.cp4}
  95.   PROCEDURE HangUpPhone; {hang up by terminating the line}
  96.     BEGIN
  97.       port[base+4] := 0;
  98.     END;
  99.  
  100.  
  101. {.cp7}
  102.   FUNCTION status: integer;
  103.     VAR st: integer;
  104.     BEGIN
  105.       st := port[base+5];
  106.       st := st shl 8 + port[base+6];
  107.       status := st;
  108.     END;
  109.  
  110.  
  111. {.cp6}
  112.   PROCEDURE send(ch: char);
  113.     VAR s: byte;
  114.     BEGIN
  115.       repeat s := port[base+5] and $20 until (s=$20);
  116.       port[base] := ord(ch);
  117.     END;
  118.  
  119.  
  120. {.cp6}
  121.   FUNCTION get_rcv_char: char;
  122.     BEGIN
  123.       get_rcv_char := chr(rcvbuf[outptr]);
  124.       outptr := (outptr + 1) and $7F;
  125.       if inptr=outptr then datardy := false;
  126.     END;
  127.  
  128.  
  129. {.cp5}
  130.   FUNCTION receive: char;
  131.     BEGIN
  132.       repeat until datardy;
  133.       receive := get_rcv_char;
  134.     END;
  135.  
  136.  
  137. {.cp9}
  138.   FUNCTION ReadLine(seconds:integer): integer;
  139.     VAR j : integer;
  140.     BEGIN
  141.       j := loopspersec * seconds;
  142.       repeat  j := j-1  until datardy or (j = 0);
  143.       if j = 0
  144.         then readline := timeout
  145.         else readline := ord(get_rcv_char);
  146.     END;
  147.  
  148.  
  149. {.cp8}
  150.   PROCEDURE PurgeLine;   {purge the receive register}
  151.     VAR c: char;
  152.     BEGIN
  153.       repeat
  154.           if datardy then c := get_rcv_char;
  155.           delay(35);   { 300 baud time period for received char }
  156.         until not(datardy)
  157.     END;
  158.  
  159.  
  160. {.cp42}
  161.   PROCEDURE Set_RS232_Vector;
  162.  
  163.     PROCEDURE Int_Handler;
  164.     { This routine buffers all incoming received data }
  165.       BEGIN
  166.         inline($50/$52/$57/$1E/                     {save registers}
  167.         $2E/             {CS:}
  168.         $8E/$1E/Intseg/  {MOV   DS,[Intseg]}        {get data segment pointer}
  169.         $BA/$FD/$03/     {MOV   DX,$3FD}            {is character ready?}
  170.         $EC/             {IN    AL,DX}
  171.         $24/$01/         {AND   AL,01}
  172.         $74/$19/         {JZ    here}               { no, skip entry}
  173.         $BA/$F8/$03/     {MOV   DX,$3F8}            { yes, get pointer}
  174.         $A1/inptr/       {MOV   AX,[inptr]}         {get index to buffer}
  175.         $97/             {XCHG  DI,AX}
  176.         $EC/             {IN    AL,DX}              {get data from receiver}
  177.         $88/$85/rcvbuf/  {MOV   [DI+rcvbuf],AL}     {put data into buffer}
  178.         $97/             {XCHG  DI,AX}              {increment pointer}
  179.         $40/             {INC   AX}
  180.         $24/$7F/         {AND   AL,$7F}
  181.         $A3/inptr/       {MOV   [inptr],AX}
  182.         $B8/$01/$00/     {MOV   AX,1}               {show data is ready}
  183.         $A2/datardy/     {MOV   [datardy],AX}
  184.                    {here}
  185.         $B0/$64/         {MOV   AL,64}              {EOI, level 4 on 8259}
  186.         $E6/$20/         {OUT   20,AL}
  187.         $1F/$5F/$5A/$58/$CF);                       {restore and return}
  188.       END;
  189.  
  190.  
  191.  
  192.     BEGIN
  193.       Intseg := Dseg;
  194.       COMbase := $0400 + 2 * (COMport - 1);
  195.       oldvec := INT4;
  196.       newvec := ptr(cseg,ofs(Int_Handler)+7+5);
  197.       INT4 := newvec;
  198.       inline($BA/$3F8/         {MOV  DX,BASE}
  199.              $EC/$EC/$EC/$EC/  {IN   AL,DX}
  200.              $BA/$3FD/$EC/     {MOV  DX,BASE+5 ! IN  AL,DX}
  201.              $BA/$3FE/$EC);    {MOV  DX,BASE+6 ! IN  AL,DX}
  202.       datardy := false;   inptr := 0;   outptr := inptr;
  203.       inline($E4/$21/$24/$EF/$E6/$21); {turn off IRQ mask bit - enabled}
  204.     END;
  205.  
  206.  
  207. {.cp16}
  208.   PROCEDURE Setup(md, brc: char);
  209.     VAR al: integer;
  210.     BEGIN
  211.       base := memw[0:COMbase];
  212.       port[base+3] := $83;         {access baud rate divisor and sets
  213.                                     8 data, no parity, 1 stop}
  214.       if md='O' then mode:=' ' else mode:='R';
  215.       baudrate := brc;
  216.       if baudrate='1'
  217.         then portw[base] := $0060     {1200 baud}
  218.         else portw[base] := $0180;    { 300 baud}
  219.       port[base+3] := $03;         {set access for xmt/rcv}
  220.       port[base+1] := $01;         {enable receiver interrupts}
  221.       SetDTR;                      {put station on-line}
  222.       return := 'N';
  223.     END;
  224.  
  225.  
  226. {.cp16}
  227.   PROCEDURE Initialize;
  228.     VAR mode, baudrate: char;
  229.     BEGIN
  230.       repeat
  231.           write('Mode : A(nswer), O(riginate) ? ');
  232.           read(kbd,mode);   mode := upcase(mode);
  233.         until mode in ['A','O'];
  234.       writeln(mode);
  235.       repeat
  236.           write('Baud rate : 3(00), 1(200) ? ');
  237.           read(kbd,baudrate);
  238.         until baudrate in ['1','3'];
  239.       writeln(baudrate);
  240.       Setup(mode,baudrate);
  241.     END;
  242.  
  243.  
  244. {.cp19}
  245.   PROCEDURE terminal;
  246.     VAR s, t: byte;
  247.         c: char;
  248.     BEGIN {$I-}  {no I/O checking here}
  249.       writeln('Use ctrl-E to exit terminal mode.');
  250.       repeat
  251.           s := port[base+5];   {get status}
  252.           if datardy
  253.             then BEGIN
  254.                    t := ord(get_rcv_char);   t := t and $7F;
  255.                    if t<>$7F then write(chr(t));
  256.                  END;
  257.             if keypressed and ((s and $20) = $20)
  258.               then BEGIN
  259.                      read(kbd,c);
  260.                      port[base] := ord(c);
  261.                    END;
  262.         until (c = ^E);
  263.     END; {$I+}
  264.  
  265.  
  266. {.cp5}
  267.   PROCEDURE sendtext(str: maxstr);
  268.     VAR i: integer;
  269.     BEGIN
  270.       for i:=1 to length(str) do send(str[i]);
  271.     END;
  272.  
  273.  
  274. {.cp20}
  275.   FUNCTION Dial(PhoneNumber: PhoneStr): char;
  276.     VAR c, kc: char;
  277.         t: integer;
  278.     BEGIN
  279.       HangUpPhone;  write(cr,lf,'Dialing: ',PhoneNumber);
  280.       delay(250);   SetDTR;   delay(250);   sendtext(cr);   delay(1000);
  281.       sendtext('AT '+mode+'M1V0DT'+PhoneNumber+cr);   delay(2000);
  282.       c := receive;   c := chr(0);   repeat  c := get_rcv_char  until (c=cr);
  283.       write(', Waiting for carrier ...');
  284.       t := 60 * loopspersec;
  285.       repeat
  286.           t := t - 1;
  287.           if datardy then c := get_rcv_char;
  288.           if keypressed then read(kbd,kc);
  289.         until (c in ['0'..'5']) or (t=0) or (kc=^E);
  290.       if c='1'
  291.         then writeln(' connected.')
  292.         else if (t=0) or (kc=^E) then c := '9';
  293.       Dial := c
  294.     END;
  295.  
  296.  
  297. {.cp15}
  298.   PROCEDURE SignOn;
  299.     VAR i: integer;
  300.         c: char;
  301.     BEGIN
  302.       write('Signing on ... ');
  303.       delay(2000);
  304.       for i:=1 to 7
  305.         do BEGIN
  306.              send('8');
  307.              delay(333);
  308.            END;
  309.       sendtext('('+cr);
  310.       delay(2500);   sendtext(SignOnLine+cr);
  311.       writeln('all set !');
  312.     END;
  313.  
  314.  
  315. {.pa}
  316.   PROCEDURE SendFile;
  317.     VAR j, sectornum, counter, checksum : integer;
  318.         filename : string[20];
  319.         c: char;
  320.  
  321.  
  322.  
  323.     PROCEDURE SendIt;
  324.       BEGIN
  325.         sectornum := 1;
  326.         repeat
  327.             counter := 0;
  328.             blockread(WorkFile,sector,1);
  329.             repeat
  330.                 write(cr,'Sending sector ', sectornum);
  331.                 send(SOH);   send(chr(sectornum));   send(chr(-sectornum-1));
  332.                 checksum := 0;
  333.                 for j:=0 to lastbyte
  334.                   do BEGIN
  335.                        send(chr(sector[j]));
  336.                        checksum := (checksum + sector[j]) mod 256
  337.                      END;
  338.                 send(chr(checksum));
  339.                 purgeline;
  340.                 counter := counter + 1;
  341.               until (readline(10) = ord(ack)) or (counter = retrymax);
  342.             sectornum := sectornum + 1
  343.           until (eof(WorkFile)) or (counter = retrymax);
  344.         if counter = retrymax
  345.           then writeln(cr,lf,'No ACK on sector')
  346.           else BEGIN
  347.                  counter := 0;
  348.                  repeat
  349.                      send(EOT);
  350.                      counter := counter + 1
  351.                    until (readline(10)=ord(ack)) or (counter=retrymax);
  352.                  if counter = retrymax
  353.                    then writeln(cr,lf,'No ACK on EOT')
  354.                    else writeln(cr,lf,'Transfer complete');
  355.                END;
  356.       END;
  357.  
  358.   BEGIN
  359.       write('Filename.Ext ? ');   readln(filename);
  360.       if length(filename)>0
  361.         then BEGIN
  362.                assign(WorkFile,filename);
  363.                reset(WorkFile);
  364.                SendIt;
  365.                close(WorkFile)
  366.              END;
  367.   END;
  368.  
  369.  
  370.  
  371. {.pa}
  372. PROCEDURE readfile;
  373.   VAR j, firstchar, sectornum,sectorcurrent, sectorcomp, errors,
  374.       checksum : integer;
  375.       errorflag : boolean;
  376.       filename : string[20];
  377.  
  378.  
  379.  
  380.   PROCEDURE ReceiveIt;
  381.     BEGIN
  382.       sectornum := 0;   errors := 0;
  383.       send(nak);   send(nak);  { send ready characters }
  384.       repeat
  385.           errorflag := false;
  386.           repeat
  387.               firstchar := readline(20)
  388.             until firstchar in [ord(SOH),ord(EOT),timeout];
  389.           if firstchar = timeout then writeln(cr,lf,'Error - No starting SOH');
  390.           if firstchar = ord(SOH)
  391.             then BEGIN
  392.                    sectorcurrent := readline(1);      {real sector number}
  393.                    sectorcomp := readline(1);         {+ inverse of above}
  394.                    if (sectorcurrent+sectorcomp)=255  {<-- becomes this #}
  395.                      then BEGIN
  396.                             if (sectorcurrent=sectornum+1)
  397.                               then BEGIN
  398.                                      checksum := 0;
  399.                                      for j := 0 to lastbyte
  400.                                        do BEGIN
  401.                                             sector[j] := readline(1);
  402.                                             checksum := (checksum+sector[j]) and $00FF
  403.                                           END;
  404.                                      if checksum=readline(1)
  405.                                        then BEGIN
  406.                                               blockwrite(WorkFile,sector,1);
  407.                                               errors := 0;
  408.                                               sectornum := sectorcurrent;
  409.                                               write(cr,'Received sector ',sectorcurrent);
  410.                                               send(ack)
  411.                                             END
  412.                                        else BEGIN
  413.                                               writeln(cr,lf,'Checksum error');
  414.                                               errorflag := true
  415.                                             END
  416.                                    END
  417.                               else if (sectorcurrent=sectornum)
  418.                                      then BEGIN
  419.                                             repeat until readline(1)=timeout;
  420.                                             writeln(cr,lf,'Received duplicate sector ', sectorcurrent);
  421.                                             send(ack)
  422.                                           END
  423.                                      else BEGIN
  424.                                             writeln(cr,lf,'Synchronization error');
  425.                                             errorflag := true
  426.                                           END
  427.                           END
  428.                      else BEGIN
  429.                             writeln(cr,lf,'Sector number error');
  430.                             errorflag := true
  431.                           END
  432.                  END;
  433.           if errorflag then BEGIN
  434.                               errors := errors+1;
  435.                               repeat until readline(1)=timeout;
  436.                               send(nak)
  437.                             END;
  438.         until (firstchar in [ord(EOT),timeout]) or (errors = errormax);
  439.       if (firstchar=ord(EOT)) and (errors<errormax)
  440.         then BEGIN
  441.                send(ack);
  442.                writeln(cr,lf,'Transfer complete')
  443.              END
  444.         else writeln(cr,lf,'Aborting');
  445.     END;
  446.  
  447.   BEGIN
  448.     write('Filename.Ext ? ');   readln(filename);
  449.     if length(filename)>0
  450.       then BEGIN
  451.              assign(WorkFile,filename);
  452.              rewrite(WorkFile);
  453.              ReceiveIt;
  454.              close(WorkFile);
  455.            END;
  456.   END;
  457.  
  458.  
  459.  
  460. {.cp17}
  461.   FUNCTION ReadPhoneList: integer;
  462.     VAR index: integer;
  463.     BEGIN
  464.       assign(PhoneFile,'MODEM.PHN');
  465.       index := 0;
  466.       {$I-}  reset(PhoneFile);  {$I+}
  467.       if IOresult=0
  468.         then BEGIN
  469.                while (not eof(PhoneFile)) and (index<26)
  470.                  do BEGIN
  471.                       index := index + 1;
  472.                       readln(PhoneFile,PhoneList[index]);
  473.                     END;
  474.                close(PhoneFile);
  475.              END;
  476.       ReadPhoneList := index;
  477.     END;
  478.  
  479.  
  480.  
  481. {.cp41}
  482.   PROCEDURE Call;
  483.     VAR rc: char;
  484.         selection, i, j, k: integer;
  485.         PhoneNo: PhoneStr;
  486.     BEGIN
  487.       if N_Phones>0
  488.         then BEGIN
  489.                clrscr;   writeln;
  490.                for i:=1 to N_Phones
  491.                  do BEGIN
  492.                       if (i mod 2)=0
  493.                         then write('      ')
  494.                         else writeln;
  495.                       write(chr(i+64),' - ',PhoneList[i]);
  496.                     END;
  497.                writeln;   writeln;   write('Enter selection letter: ');
  498.                repeat
  499.                    repeat until keypressed;
  500.                    read(kbd,rc);   rc := upcase(rc);
  501.                    selection := ord(rc) - ord('@');
  502.                  until (selection in [1..N_Phones]);
  503.                writeln(rc);
  504.                mode     := PhoneList[selection][31];
  505.                baudrate := PhoneList[selection][32];
  506.                Setup(mode,baudrate);
  507.                j := 30;   PhoneNo := '';
  508.                while PhoneList[selection][j]<>'.' do j:=j-1;
  509.                for k:=j+1 to 30 do PhoneNo := PhoneNo + PhoneList[selection][k];
  510.                rc := Dial(PhoneNo);
  511.              END
  512.         else rc := Dial(FredsPhone);
  513.       if rc='1'
  514.         then BEGIN
  515.                if N_Phones=0
  516.                  then SignOn
  517.                  else if selection=1 then Signon;
  518.                terminal;
  519.              END
  520.         else HangUpPhone;
  521.     END;
  522.  
  523.  
  524.  
  525. {.cp22}
  526.   PROCEDURE GetOption;
  527.     BEGIN
  528.       clrscr;
  529.       writeln('Modem, ',Version);
  530.       gotoxy(7,4);   writeln('Options:');
  531.       writeln;
  532.       writeln('  R - receive a file');
  533.       writeln('  S - send a file');
  534.       writeln('  T - terminal mode');
  535.       writeln;
  536.       writeln('  C - place a call');
  537.       writeln('  H - hang up the phone');
  538.       writeln('  O - option configuration');
  539.       writeln('  X - exit to system');
  540.       writeln;   write('which ? ');
  541.       repeat
  542.           read(kbd,option);
  543.           option := upcase(option);
  544.         until option IN ['O','C','R','S','T','H','X'];
  545.       writeln(option);
  546.     END;
  547.  
  548.  
  549.  
  550. {.cp16}
  551. BEGIN {Modem}
  552.   Set_RS232_Vector;
  553.   N_Phones := ReadPhoneList;
  554.   Setup('O','1');   { default of Originate/1200 baud }
  555.   repeat
  556.       GetOption;
  557.       case option of
  558.         'T': Terminal;
  559.         'R': ReadFile;
  560.         'S': SendFile;
  561.         'O': Initialize;
  562.         'C': Call;
  563.         'H': HangUpPhone;
  564.         'X': return := 'Y';
  565.       END;
  566.     until return='Y';
  567.   inline($E4/$21/$0C/$10/$E6/$21); {turn on IRQ mask bit - disabled}
  568. (*  INT4 := oldvec;  {restore the old RS232 vector} *)
  569. END.
  570.